home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / File / Spec / Win32.pm < prev   
Encoding:
Perl POD Document  |  2009-06-26  |  9.3 KB  |  379 lines
  1. package File::Spec::Win32;
  2.  
  3. use strict;
  4.  
  5. use vars qw(@ISA $VERSION);
  6. require File::Spec::Unix;
  7.  
  8. $VERSION = '3.2501';
  9.  
  10. @ISA = qw(File::Spec::Unix);
  11.  
  12. # Some regexes we use for path splitting
  13. my $DRIVE_RX = '[a-zA-Z]:';
  14. my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
  15. my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
  16.  
  17.  
  18. =head1 NAME
  19.  
  20. File::Spec::Win32 - methods for Win32 file specs
  21.  
  22. =head1 SYNOPSIS
  23.  
  24.  require File::Spec::Win32; # Done internally by File::Spec if needed
  25.  
  26. =head1 DESCRIPTION
  27.  
  28. See File::Spec::Unix for a documentation of the methods provided
  29. there. This package overrides the implementation of these methods, not
  30. the semantics.
  31.  
  32. =over 4
  33.  
  34. =item devnull
  35.  
  36. Returns a string representation of the null device.
  37.  
  38. =cut
  39.  
  40. sub devnull {
  41.     return "nul";
  42. }
  43.  
  44. sub rootdir () { '\\' }
  45.  
  46.  
  47. =item tmpdir
  48.  
  49. Returns a string representation of the first existing directory
  50. from the following list:
  51.  
  52.     $ENV{TMPDIR}
  53.     $ENV{TEMP}
  54.     $ENV{TMP}
  55.     SYS:/temp
  56.     C:\system\temp
  57.     C:/temp
  58.     /tmp
  59.     /
  60.  
  61. The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
  62. for Symbian (the File::Spec::Win32 is used also for those platforms).
  63.  
  64. Since Perl 5.8.0, if running under taint mode, and if the environment
  65. variables are tainted, they are not used.
  66.  
  67. =cut
  68.  
  69. my $tmpdir;
  70. sub tmpdir {
  71.     return $tmpdir if defined $tmpdir;
  72.     $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
  73.                   'SYS:/temp',
  74.                   'C:\system\temp',
  75.                   'C:/temp',
  76.                   '/tmp',
  77.                   '/'  );
  78. }
  79.  
  80. =item case_tolerant
  81.  
  82. MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
  83. indicating the case significance when comparing file specifications.
  84. Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
  85. See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
  86. Default: 1
  87.  
  88. =cut
  89.  
  90. sub case_tolerant () {
  91.   eval { require Win32API::File; } or return 1;
  92.   my $drive = shift || "C:";
  93.   my $osFsType = "\0"x256;
  94.   my $osVolName = "\0"x256;
  95.   my $ouFsFlags = 0;
  96.   Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
  97.   if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
  98.   else { return 1; }
  99. }
  100.  
  101. =item file_name_is_absolute
  102.  
  103. As of right now, this returns 2 if the path is absolute with a
  104. volume, 1 if it's absolute with no volume, 0 otherwise.
  105.  
  106. =cut
  107.  
  108. sub file_name_is_absolute {
  109.  
  110.     my ($self,$file) = @_;
  111.  
  112.     if ($file =~ m{^($VOL_RX)}o) {
  113.       my $vol = $1;
  114.       return ($vol =~ m{^$UNC_RX}o ? 2
  115.           : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
  116.           : 0);
  117.     }
  118.     return $file =~  m{^[\\/]} ? 1 : 0;
  119. }
  120.  
  121. =item catfile
  122.  
  123. Concatenate one or more directory names and a filename to form a
  124. complete path ending with a filename
  125.  
  126. =cut
  127.  
  128. sub catfile {
  129.     my $self = shift;
  130.     my $file = $self->canonpath(pop @_);
  131.     return $file unless @_;
  132.     my $dir = $self->catdir(@_);
  133.     $dir .= "\\" unless substr($dir,-1) eq "\\";
  134.     return $dir.$file;
  135. }
  136.  
  137. sub catdir {
  138.     my $self = shift;
  139.     my @args = @_;
  140.     foreach (@args) {
  141.     tr[/][\\];
  142.         # append a backslash to each argument unless it has one there
  143.         $_ .= "\\" unless m{\\$};
  144.     }
  145.     return $self->canonpath(join('', @args));
  146. }
  147.  
  148. sub path {
  149.     my @path = split(';', $ENV{PATH});
  150.     s/"//g for @path;
  151.     @path = grep length, @path;
  152.     unshift(@path, ".");
  153.     return @path;
  154. }
  155.  
  156. =item canonpath
  157.  
  158. No physical check on the filesystem, but a logical cleanup of a
  159. path. On UNIX eliminated successive slashes and successive "/.".
  160. On Win32 makes 
  161.  
  162.     dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
  163.     dir1\dir2\dir3\...\dir4   -> \dir\dir4
  164.  
  165. =cut
  166.  
  167. sub canonpath {
  168.     my ($self,$path) = @_;
  169.     
  170.     $path =~ s/^([a-z]:)/\u$1/s;
  171.     $path =~ s|/|\\|g;
  172.     $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
  173.     $path =~ s|(\\\.)+\\|\\|g;                     # xx\.\.\xx -> xx\xx
  174.     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
  175.     $path =~ s|\\\Z(?!\n)||
  176.     unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s;  # xx\       -> xx
  177.     # xx1/xx2/xx3/../../xx -> xx1/xx
  178.     $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
  179.     $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g;    # ...\ is 2 levels up
  180.     return $path if $path =~ m|^\.\.|;      # skip relative paths
  181.     return $path unless $path =~ /\.\./;    # too few .'s to cleanup
  182.     return $path if $path =~ /\.\.\.\./;    # too many .'s to cleanup
  183.     $path =~ s{^\\\.\.$}{\\};                      # \..    -> \
  184.     1 while $path =~ s{^\\\.\.}{};                 # \..\xx -> \xx
  185.  
  186.     return $self->_collapse($path);
  187. }
  188.  
  189. =item splitpath
  190.  
  191.     ($volume,$directories,$file) = File::Spec->splitpath( $path );
  192.     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
  193.  
  194. Splits a path into volume, directory, and filename portions. Assumes that 
  195. the last file is a path unless the path ends in '\\', '\\.', '\\..'
  196. or $no_file is true.  On Win32 this means that $no_file true makes this return 
  197. ( $volume, $path, '' ).
  198.  
  199. Separators accepted are \ and /.
  200.  
  201. Volumes can be drive letters or UNC sharenames (\\server\share).
  202.  
  203. The results can be passed to L</catpath> to get back a path equivalent to
  204. (usually identical to) the original path.
  205.  
  206. =cut
  207.  
  208. sub splitpath {
  209.     my ($self,$path, $nofile) = @_;
  210.     my ($volume,$directory,$file) = ('','','');
  211.     if ( $nofile ) {
  212.         $path =~ 
  213.             m{^ ( $VOL_RX ? ) (.*) }sox;
  214.         $volume    = $1;
  215.         $directory = $2;
  216.     }
  217.     else {
  218.         $path =~ 
  219.             m{^ ( $VOL_RX ? )
  220.                 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
  221.                 (.*)
  222.              }sox;
  223.         $volume    = $1;
  224.         $directory = $2;
  225.         $file      = $3;
  226.     }
  227.  
  228.     return ($volume,$directory,$file);
  229. }
  230.  
  231.  
  232. =item splitdir
  233.  
  234. The opposite of L<catdir()|File::Spec/catdir()>.
  235.  
  236.     @dirs = File::Spec->splitdir( $directories );
  237.  
  238. $directories must be only the directory portion of the path on systems 
  239. that have the concept of a volume or that have path syntax that differentiates
  240. files from directories.
  241.  
  242. Unlike just splitting the directories on the separator, leading empty and 
  243. trailing directory entries can be returned, because these are significant
  244. on some OSs. So,
  245.  
  246.     File::Spec->splitdir( "/a/b/c" );
  247.  
  248. Yields:
  249.  
  250.     ( '', 'a', 'b', '', 'c', '' )
  251.  
  252. =cut
  253.  
  254. sub splitdir {
  255.     my ($self,$directories) = @_ ;
  256.     #
  257.     # split() likes to forget about trailing null fields, so here we
  258.     # check to be sure that there will not be any before handling the
  259.     # simple case.
  260.     #
  261.     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
  262.         return split( m|[\\/]|, $directories );
  263.     }
  264.     else {
  265.         #
  266.         # since there was a trailing separator, add a file name to the end, 
  267.         # then do the split, then replace it with ''.
  268.         #
  269.         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
  270.         $directories[ $#directories ]= '' ;
  271.         return @directories ;
  272.     }
  273. }
  274.  
  275.  
  276. =item catpath
  277.  
  278. Takes volume, directory and file portions and returns an entire path. Under
  279. Unix, $volume is ignored, and this is just like catfile(). On other OSs,
  280. the $volume become significant.
  281.  
  282. =cut
  283.  
  284. sub catpath {
  285.     my ($self,$volume,$directory,$file) = @_;
  286.  
  287.     # If it's UNC, make sure the glue separator is there, reusing
  288.     # whatever separator is first in the $volume
  289.     my $v;
  290.     $volume .= $v
  291.         if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
  292.              $directory =~ m@^[^\\/]@s
  293.            ) ;
  294.  
  295.     $volume .= $directory ;
  296.  
  297.     # If the volume is not just A:, make sure the glue separator is 
  298.     # there, reusing whatever separator is first in the $volume if possible.
  299.     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
  300.          $volume =~ m@[^\\/]\Z(?!\n)@      &&
  301.          $file   =~ m@[^\\/]@
  302.        ) {
  303.         $volume =~ m@([\\/])@ ;
  304.         my $sep = $1 ? $1 : '\\' ;
  305.         $volume .= $sep ;
  306.     }
  307.  
  308.     $volume .= $file ;
  309.  
  310.     return $volume ;
  311. }
  312.  
  313. sub _same {
  314.   lc($_[1]) eq lc($_[2]);
  315. }
  316.  
  317. sub rel2abs {
  318.     my ($self,$path,$base ) = @_;
  319.  
  320.     my $is_abs = $self->file_name_is_absolute($path);
  321.  
  322.     # Check for volume (should probably document the '2' thing...)
  323.     return $self->canonpath( $path ) if $is_abs == 2;
  324.  
  325.     if ($is_abs) {
  326.       # It's missing a volume, add one
  327.       my $vol = ($self->splitpath( $self->_cwd() ))[0];
  328.       return $self->canonpath( $vol . $path );
  329.     }
  330.  
  331.     if ( !defined( $base ) || $base eq '' ) {
  332.       require Cwd ;
  333.       $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
  334.       $base = $self->_cwd() unless defined $base ;
  335.     }
  336.     elsif ( ! $self->file_name_is_absolute( $base ) ) {
  337.       $base = $self->rel2abs( $base ) ;
  338.     }
  339.     else {
  340.       $base = $self->canonpath( $base ) ;
  341.     }
  342.  
  343.     my ( $path_directories, $path_file ) =
  344.       ($self->splitpath( $path, 1 ))[1,2] ;
  345.  
  346.     my ( $base_volume, $base_directories ) =
  347.       $self->splitpath( $base, 1 ) ;
  348.  
  349.     $path = $self->catpath( 
  350.                $base_volume, 
  351.                $self->catdir( $base_directories, $path_directories ), 
  352.                $path_file
  353.               ) ;
  354.  
  355.     return $self->canonpath( $path ) ;
  356. }
  357.  
  358. =back
  359.  
  360. =head2 Note For File::Spec::Win32 Maintainers
  361.  
  362. Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
  363.  
  364. =head1 COPYRIGHT
  365.  
  366. Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
  367.  
  368. This program is free software; you can redistribute it and/or modify
  369. it under the same terms as Perl itself.
  370.  
  371. =head1 SEE ALSO
  372.  
  373. See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  374. implementation of these methods, not the semantics.
  375.  
  376. =cut
  377.  
  378. 1;
  379.